home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
eev100r1.zip
/
POSTFIX.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-01-03
|
16KB
|
710 lines
Unit PostFix;
{ ------------------------------------------------------------------------
POSTFIX.PAS
------------------------------------------------------------------------
Version 1.00, Revision 0, December 28, 1991
Written by: David J. Firth
5665-A2 Parkville St.
Columbus, OH 43229
This unit provides a complete reverse polish notation (RPN) expression
evaluator. Each part of the RPN expression needs to be separated by a
space. The evaluator supports the following functions:
+ - * / PI ABS ARCTAN COS EXP LN SQR SQRT
The RPN evaluator does not have its own tokenizer. Instead, since
the expression tokens must be separated by spaces, Turbo's own
ParamStr tokenizer can be fooled into doing the job. Due to the
limitations imposed by DOS on the size of the command tail, the
length of the string to evaluate will be truncated at 120 characters.
My thanks to PC Techniques magazine for printing a HAX with this
suggestion in it.
The evaluator package includes routines to read and write values
to and from variables. Variables should be 20 or characters or
less in length. During expression evaluation, any unrecognized
string of characters will be assumed to be a variable.
Two procedures are provided for expression evaluation, Calculate and
CalcAndStore. Calculate will evaluate the expression and return the
result to the caller. CalcAndStore will evaluate the expression and
store the result in a variable.
POSTFIX.PAS has two major data structures allocated on the heap.
The first is a stack, used for the processing of RPN expressions.
The other is a linked list used to store variables. Before the
application program is ended, the procedure DestroyList should
be called to deallocate the memory taken by these structures.
------------------------------------------------------------------------ }
Interface
type
Str20 = string[20]; {store variable IDs this way to conserve}
Str128 = string[128];
VariablePtr = ^VariableType; {for dynamic allocation of records }
VariableType = record
ID : Str20; {the id of the variable, with @s }
Value : real; {the current value of the variable }
Next : VariablePtr; {hook to next record in linked list}
end; {VariableType}
StackItemPtr = ^StackItemType; {for dynamic allocation of records }
StackItemType = record
Value : real; {the value to be "operated" upon }
Next : StackItemPtr; {hook to next record in linked list}
end; {StackItemType}
var
HPtr, {head of variable list }
TPtr, {tail of variable list }
SPtr : VariablePtr; {used to search variable list}
STPtr : StackItemPtr; {the top of the stack}
procedure StoreVariable(VariableID:str20;MyValue:real);
procedure ReadVariable(VariableID:str20;var MyValue:real;var MyError:boolean);
procedure DestroyList;
procedure Calculate(MyFormula:string;var MyResult:real;var MyError:boolean);
procedure CalcAndStore(MyFormula:string;StoreID:str20;var MyError:boolean);
Implementation
Uses
DFStr;
{ ------------------------------------------------------------------------ }
function __ParamCount(MyStr:string):byte;
{this routine is a work-alike of Turbo's own ParamCount function. this
routine requires my DFStr unit to operate.}
var
Count,
Index : byte;
begin
MyStr := __RemWhiteStr(MyStr,_Leading);
MyStr := __RemWhiteStr(MyStr,_Trailing);
Count := 0;
for Index := 1 to length(MyStr) do
if MyStr[Index]=' ' then inc(Count);
__ParamCount := Count+1;
end; {__ParamCount}
{ ------------------------------------------------------------------------ }
function __ParamStr(Index:byte;MyStr:string):string;
var
TempStr : string;
I,
J,
P,
Count : byte;
Spaces : array[0..256] of byte;
begin
TempStr := '';
fillchar(Spaces,sizeof(Spaces),0);
Count := __ParamCount(MyStr);
if (Index<=Count) AND (Index>0) then begin
MyStr := __RemWhiteStr(MyStr,_Leading);
MyStr := __RemWhiteStr(MyStr,_Trailing);
MyStr := ' ' + MyStr + ' ';
{load Spaces}
J := 0;
for I := 1 to length(MyStr) do begin
if MyStr[I] = ' ' then begin
Spaces[J] := I;
inc(J);
end;
end; {for}
{get the parameter}
TempStr := copy(MyStr,Spaces[Index-1]+1,Spaces[Index]-Spaces[Index-1]-1);
end;
__ParamStr := TempStr;
end; {__ParamStr}
{ ------------------------------------------------------------------------ }
procedure Pop(var MyValue:real;var MyError:boolean);
var
TempPtr : StackItemPtr;
begin
if STPtr=nil then begin
{tried to pop empty stack -- error!}
MyValue := 0;
MyError := true;
end
else begin
{get value}
MyValue := STPtr^.Value;
MyError := false;
{dispose of the record at the top of the stack}
TempPtr := STPtr;
STPtr := STPtr^.Next;
dispose(TempPtr);
end; {if-else}
end; {Pop}
{ ------------------------------------------------------------------------ }
procedure Push(MyValue:real);
var
TempPtr : StackItemPtr;
begin
{create record on heap for value}
new(TempPtr);
TempPtr^.Value := MyValue;
{attach new record as top of stack}
TempPtr^.Next := STPtr;
STPtr := TempPtr;
end; {Push}
{ ------------------------------------------------------------------------ }
procedure DestroyStack(MyPtr:StackItemPtr);
begin
if MyPtr^.Next<>nil then
DestroyStack(MyPtr^.Next);
dispose(MyPtr);
end; {DestroyStack}
{ ------------------------------------------------------------------------ }
procedure GetPointerTo(VariableID:str20;var MPtr:VariablePtr);
var
Done : boolean;
XPtr : VariablePtr;
begin
MPtr := nil;
XPtr := HPtr;
Done := false;
while (not Done) do begin
if XPtr^.ID=VariableID then
MPtr := XPtr;
if XPtr^.Next=nil then
Done := true
else
XPtr := XPtr^.Next;
end; {while}
end; {GetPointerTo}
{ ------------------------------------------------------------------------ }
procedure ReadVariable(VariableID:str20;var MyValue:real;var MyError:boolean);
var
MPtr : VariablePtr;
begin
MyError := false;
MyValue := 0;
GetPointerTo(VariableID,MPtr);
if MPtr<>nil then begin
MyValue := MPtr^.Value
end
else begin
MyError := true;
end;
end; {ReadVariable}
{ ------------------------------------------------------------------------ }
procedure StoreVariable(VariableID:str20;MyValue:real);
var
WorkingRec : VariableType;
begin
fillchar(WorkingRec,sizeof(WorkingRec),0);
WorkingRec.ID := VariableID;
WorkingRec.Value := MyValue;
If HPtr = nil then begin
{this is the first record added to the list}
New(HPtr); {allocate 1st record in LL }
TPtr := HPtr; {init tail (= head) }
TPtr^ := WorkingRec; {add new record as head }
TPtr^.Next := nil; {set the next link for tail}
end
else begin
GetPointerTo(VariableID,SPtr);
if SPtr <> nil then begin
{the list exists and so does the variable -- modify value}
SPtr^.Value := MyValue;
end
else begin
{the list exists, but the variable doesn't -- add it}
New(SPtr); {allocate new record for LL }
SPtr^ := WorkingRec; {put info in new LL record }
TPtr^.Next := SPtr; {add new record as tail }
SPtr^.Next := nil; {set the new link for tail }
TPtr := SPtr; {point tail to new record }
end; {if-else}
end;
end; {StoreVariable}
{ ------------------------------------------------------------------------- }
Procedure DestroyFieldList(TempPtr:VariablePtr);
{ This procedure recursively destroys a linked list }
Begin
If TempPtr^.Next <> nil then
DestroyFieldList(TempPtr^.Next);
Dispose(TempPtr);
End;
{ ------------------------------------------------------------------------ }
procedure DestroyList;
begin
if HPtr <> Nil then
DestroyFieldList(HPtr);
HPtr := nil;
TPtr := nil;
SPtr := nil;
if STPtr<>nil then
DestroyStack(STPtr);
STPtr := nil;
end; {DestroyList}
{ ------------------------------------------------------------------------ }
procedure DoAdd(var MyError:boolean);
var
A,B : real;
begin
Pop(A,MyError);
if not MyError then begin
Pop(B,MyError);
if not MyError then Push(A+B)
end;
end; {DoAdd}
{ ------------------------------------------------------------------------ }
procedure DoSub(var MyError:boolean);
var
A,B : real;
begin
Pop(A,MyError);
if not MyError then begin
Pop(B,MyError);
if not MyError then Push(B-A)
end;
end; {DoSub}
{ ------------------------------------------------------------------------ }
procedure DoMul(var MyError:boolean);
var
A,B : real;
begin
Pop(A,MyError);
if not MyError then begin
Pop(B,MyError);
if not MyError then Push(A*B)
end;
end; {DoMul}
{ ------------------------------------------------------------------------ }
procedure DoPI(var MyError:boolean);
begin
MyError := false;
Push(3.1415927);
end; {DoPI}
{ ------------------------------------------------------------------------ }
procedure DoABS(var MyError:boolean);
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(abs(A))
end;
end; {DoABS}
{ ------------------------------------------------------------------------ }
procedure DoATAN(var MyError:boolean);
{this function works in radians}
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(arctan(A));
end;
end; {DoATAN}
{ ------------------------------------------------------------------------ }
procedure DoCOS(var MyError:boolean);
{this function works in radians}
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(cos(A));
end;
end; {DoCOS}
{ ------------------------------------------------------------------------ }
procedure DoEXP(var MyError:boolean);
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(exp(A));
end;
end; {DoEXP}
{ ------------------------------------------------------------------------ }
procedure DoLN(var MyError:boolean);
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(ln(A));
end;
end; {DoLN}
{ ------------------------------------------------------------------------ }
procedure DoSQR(var MyError:boolean);
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(A*A);
end;
end; {DoSQR}
{ ------------------------------------------------------------------------ }
procedure DoSQRT(var MyError:boolean);
var
A : real;
begin
Pop(A,MyError);
if not MyError then begin
Push(sqrt(A));
end;
end; {DoSQRT}
{ ------------------------------------------------------------------------ }
procedure DoDiv(var MyError:boolean);
var
A,B : real;
begin
Pop(A,MyError);
if not MyError then begin
Pop(B,MyError);
if not MyError then Push(B/A)
end;
end; {DoDiv}
{ ------------------------------------------------------------------------ }
procedure Calculate(MyFormula:string;var MyResult:real;var MyError:boolean);
const
NumFunctions = 12;
MyFunctions : array[1..NumFunctions] of string = ('+',
'-',
'*',
'/',
'PI',
'ABS',
'ARCTAN',
'COS',
'EXP',
'LN',
'SQR',
'SQRT');
var
Index,
TokenID,
TokenNum,
NumTokens : byte;
CmdTail : ^Str128;
Token : string;
ValError : integer;
ValReal : real;
VarStr : Str20;
begin
{set up error condition}
MyError := false;
MyResult := 0;
NumTokens := __ParamCount(MyFormula);
if NumTokens>0 then begin
TokenNum := 1;
while (TokenNum<=NumTokens) AND (not MyError) do begin
Token := __ParamStr(TokenNum,MyFormula);
val(Token,ValReal,ValError);
if ValError=0 then begin
{token is a valid number - push onto stack}
Push(ValReal);
end
else begin
{token wasn't a number, is it an operator?}
{convert to all caps}
for Index := 1 to length(Token) do
Token[Index] := upcase(Token[Index]);
{search valid functions}
TokenID := 0;
for Index := 1 to NumFunctions do
if MyFunctions[Index]=Token then TokenID := Index;
case TokenID of
0: begin
{search valid variables for Token}
VarStr := copy(Token,1,20);
ReadVariable(VarStr,ValReal,MyError);
if not MyError then
{push variable's value onto stack}
Push(ValReal);
end; {0}
1: DoAdd(MyError);
2: DoSub(MyError);
3: DoMul(MyError);
4: DoDiv(MyError);
5: DoPI(MyError);
6: DoABS(MyError);
7: DoATAN(MyError);
8: DoCOS(MyError);
9: DoEXP(MyError);
10: DoLN(MyError);
11: DoSQR(MyError);
12: DoSQRT(MyError);
end; {case}
end; {if-else}
{point to next token}
inc(TokenNum);
end; {while}
end
else
MyError := true;
if not MyError then
{the result of the evaluator is on the stack}
Pop(MyResult,MyError)
else
{problem -- destroy stack}
if STPtr<>nil then DestroyStack(STPtr);
end; {Calculate}
{ ------------------------------------------------------------------------ }
procedure CalcAndStore(MyFormula:string;StoreID:str20;var MyError:boolean);
var
MyResult : real;
begin
{call calculate to evaluate the expression}
Calculate(MyFormula,MyResult,MyError);
{store the result in a variable}
if not MyError then
StoreVariable(StoreID,MyResult);
end; {Calculate}
{ ------------------------------------------------------------------------ }
begin {init block}
{set up linked list to empty state}
HPtr := nil;
TPtr := nil;
SPtr := nil;
{set up the stack}
STPtr := nil;
end. {unit PostFix}
